Unit
	CaptivePortal;

Interface

Uses
	Classes,
	SysUtils,
	StrUtils,
	BlckSock,
	HTTPHandling,
	ReadExternalApp;

Const
	aDefaultRedirectorPage = '/etc/captiveportal/redirect.html';
	aDefaultLoginPage = '/etc/captiveportal/login.html';
	aDefaultErrorPage = '/etc/captiveportal/error.html';
	aDefaultOKPage = '/etc/captiveportal/onlogin.html';
	aDefaultLoginProgram = '/etc/captiveportal/onlogin.sh';
	aDefaultPortalIP = '127.0.0.1';
	aDefaultPortalPort = '4550';
	aDefaultPortalProtocol = 'http';
	aDefaultRedirectorIP = '127.0.0.1';
	aDefaultRedirectorPort = '4551';

Type
	TRedirectorThread = Class(TThread)
	Private
		fPortalIP,
		fPortalPort,
		fPortalProtocol,
		fRedirectorIP,
		fRedirectorPort : String;
		fSocket : TTCPBlockSocket;
	Public
		Constructor Create(Const aPortalIP, aPortalPort, aPortalProtocol, aRedirectorIP, aRedirectorPort : String);
		Destructor Destroy; Override;
		Procedure Execute; Override;
	End;
	
	TRedirectorWorkerThread = Class(TThread)
	Private
		fPortalIP,
		fPortalPort,
		fPortalProtocol : String;
		fSocket : TTCPBlockSocket;
	Public
		Constructor Create(Const aPortalIP, aPortalPort, aPortalProtocol : String; Const aSocket : TTCPBlockSocket);
		Destructor Destroy; Override;
		Procedure Execute; Override;
	End;
	
	TPortalThread = Class(TThread)
	Private
		fPortalIP,
		fPortalPort,
		fPortalProtocol : String;
		fSocket : TTCPBlockSocket;
	Public
		Constructor Create(Const aPortalIP, aPortalPort, aPortalProtocol : String);
		Destructor Destroy; Override;
		Procedure Execute; Override;
	End;
	
	TPortalWorkerThread = Class(TThread)
	Private
		fPortalIP,
		fPortalPort,
		fPortalProtocol : String;
		fSocket : TTCPBlockSocket;
	Public
		Constructor Create(Const aPortalIP, aPortalPort, aPortalProtocol : String; Const aSocket : TTCPBlockSocket);
		Destructor Destroy; Override;
		Procedure Execute; Override;
	End;

Implementation

Function SetValueOrDefault(Const aValue, aDefault : String): String;
Begin
	If aValue = '' Then
		Result := aDefault
	Else
		Result := aValue;
End;

// TRedirectorThread

Constructor TRedirectorThread.Create(Const aPortalIP, aPortalPort, aPortalProtocol, aRedirectorIP, aRedirectorPort : String);
Begin
	Inherited Create(True);
	FreeOnTerminate := False;
	fPortalIP := SetValueOrDefault(aPortalIP, aDefaultPortalIP);
	fPortalPort := SetValueOrDefault(aPortalPort, aDefaultPortalPort);
	fPortalProtocol := SetValueOrDefault(aPortalProtocol, aDefaultPortalProtocol);
	fRedirectorIP := SetValueOrDefault(aRedirectorIP, aDefaultRedirectorIP);
	fRedirectorPort := SetValueOrDefault(aRedirectorPort, aDefaultRedirectorPort);
	fSocket := TTCPBlockSocket.Create;
	CheckSocketError(fSocket);
	fSocket.SetLinger(True, 1000);
	CheckSocketError(fSocket);
	fSocket.Bind(fRedirectorIP, fRedirectorPort);
	CheckSocketError(fSocket);
	fSocket.Listen;
	CheckSocketError(fSocket);
End;

Destructor TRedirectorThread.Destroy;
Begin
	FreeAndNil(fSocket);
	Inherited Destroy;
End;

Procedure TRedirectorThread.Execute;
Var
	lSocket : TTCPBlockSocket;
Begin
	While True Do
		With fSocket Do 
			If fSocket.CanRead(1000) Then
			Begin
				{ Debug } WriteLn('Incomming connection.');
				CheckSocketError(fSocket);
				lSocket := TTCPBlockSocket.Create;
				lSocket.Socket := fSocket.Accept;
				lSocket.GetSins;
				TRedirectorWorkerThread.Create(fPortalIP, fPortalPort, fPortalProtocol, lSocket).Start;
			End;
End;
	
// TRedirectorWorkerThread

Constructor TRedirectorWorkerThread.Create(Const aPortalIP, aPortalPort, aPortalProtocol : String; Const aSocket : TTCPBlockSocket);
Begin
	Inherited Create(True);
	FreeOnTerminate := True;
	fPortalIP := SetValueOrDefault(aPortalIP, aDefaultPortalIP);
	fPortalPort := SetValueOrDefault(aPortalPort, aDefaultPortalPort);
	fPortalProtocol := SetValueOrDefault(aPortalProtocol, aDefaultPortalProtocol);
	fSocket := aSocket;
End;

Destructor TRedirectorWorkerThread.Destroy;
Begin
	FreeAndNil(fSocket);
	Inherited Destroy;
End;

Procedure TRedirectorWorkerThread.Execute;
Var
	lHTTPRequest : THTTPRequest;
	lHTTPResponse : THTTPResponse;
	lRedirPage : TStringList;
	lDummy,
	lParameters : String;
Begin
	{ Debug } WriteLn('TRedirectorWorkerThread.Execute;');
	lRedirPage := TStringList.Create;
	lHTTPRequest := THTTPRequest.Create;
	lHTTPResponse := THTTPResponse.Create;
	Try
		lRedirPage.LoadFromFile(aDefaultRedirectorPage);		
		lHTTPRequest.ReadFromSocket(fSocket);
		lParameters := lHTTPRequest.URI;
		lDummy := Copy2SymbDel(lParameters, '?');
		If Assigned(lHTTPRequest.Headers.Find('host')) Then
			lRedirPage.Text := StringReplace(lRedirPage.Text, '$originalurl$', URLEncodeString(lHTTPRequest.Headers['host'] + '?' + lParameters), [ rfReplaceAll, rfIgnoreCase ]);
		lRedirPage.Text := StringReplace(lRedirPage.Text, '$portalurl$', fPortalProtocol + '://' + fPortalIP + ':' + fPortalPort, [ rfReplaceAll, rfIgnoreCase ]);
		lHTTPResponse.Code := 200;
		lHTTPResponse.Reason := 'OK';
		lHTTPResponse.Protocol := 'HTTP/1.0';
		lHTTPResponse.Content := lRedirPage.Text;
		lHTTPResponse.AddHeader('Connection', 'close');
		lHTTPResponse.AddHeader('Content-Type', 'text/html');
		{ Debug } WriteLn('=====================');
		lHTTPResponse.WriteToSocket(fSocket);
	Finally
		FreeAndNil(lRedirPage);
		FreeAndNil(lHTTPResponse);
		FreeAndNil(lHTTPRequest);
	End;	
End;

// TPortalThread

Constructor TPortalThread.Create(Const aPortalIP, aPortalPort, aPortalProtocol : String);
Begin
	Inherited Create(True);
	FreeOnTerminate := False;
	FreeOnTerminate := False;
	fPortalIP := SetValueOrDefault(aPortalIP, aDefaultPortalIP);
	fPortalPort := SetValueOrDefault(aPortalPort, aDefaultPortalPort);
	fPortalProtocol := SetValueOrDefault(aPortalProtocol, aDefaultPortalProtocol);
	fSocket := TTCPBlockSocket.Create;
	CheckSocketError(fSocket);
	fSocket.SetLinger(True, 1000);
	CheckSocketError(fSocket);
	fSocket.Bind(fPortalIP, fPortalPort);
	CheckSocketError(fSocket);
	fSocket.Listen;
	CheckSocketError(fSocket);
End;

Destructor TPortalThread.Destroy;
Begin
	FreeAndNil(fSocket);
	Inherited Destroy;
End;

Procedure TPortalThread.Execute;
Var
	lSocket : TTCPBlockSocket;
Begin
	While True Do
		With fSocket Do 
			If fSocket.CanRead(1000) Then
			Begin
				{ Debug } WriteLn('Incomming connection.');
				CheckSocketError(fSocket);
				lSocket := TTCPBlockSocket.Create;
				lSocket.Socket := fSocket.Accept;
				lSocket.GetSins;
				TPortalWorkerThread.Create(fPortalIP, fPortalPort, fPortalProtocol, lSocket).Start;
			End;
End;
	
// TPortalWorkerThread

Constructor TPortalWorkerThread.Create(Const aPortalIP, aPortalPort, aPortalProtocol : String; Const aSocket : TTCPBlockSocket);
Begin
	Inherited Create(True);
	FreeOnTerminate := True;
	fSocket := aSocket;
	fPortalIP := SetValueOrDefault(aPortalIP, aDefaultPortalIP);
	fPortalPort := SetValueOrDefault(aPortalPort, aDefaultPortalPort);
	fPortalProtocol := SetValueOrDefault(aPortalProtocol, aDefaultPortalProtocol);
End;

Destructor TPortalWorkerThread.Destroy;
Begin
	FreeAndNil(fSocket);
	Inherited Destroy;
End;

Procedure TPortalWorkerThread.Execute;
Var
	lHTTPRequest : THTTPRequest;
	lHTTPResponse : THTTPResponse;
	lLoginPage : TStringList;
	lErrorPage : TStringList;
	lOKPage : TStringList;

	Procedure ReadPages;
	Begin
		Try
			lLoginPage.LoadFromFile(aDefaultLoginPage);
			lErrorPage.LoadFromFile(aDefaultErrorPage);
			lOKPage.LoadFromFile(aDefaultOkPage);
			If Assigned(lHTTPRequest.Variables.Find('originalurl')) Then
			Begin
				{ Debug } WriteLn('Login page.');
				lLoginPage.Text := StringReplace(lLoginPage.Text, '$originalurl$', lHTTPRequest.Variables.Items['originalurl'], [ rfReplaceAll, rfIgnoreCase ]);
				lLoginPage.Text := StringReplace(lLoginPage.Text, '$decodedoriginalurl$', URLDecodeString(lHTTPRequest.Variables.Items['originalurl']), [ rfReplaceAll, rfIgnoreCase ]);
				lLoginPage.Text := StringReplace(lLoginPage.Text, '$portalurl$', fPortalProtocol + '://' + fPortalIP + ':' + fPortalPort, [ rfReplaceAll, rfIgnoreCase ]);
				{ Debug } WriteLn('Error page.');
				lErrorPage.Text := StringReplace(lErrorPage.Text, '$originalurl$', lHTTPRequest.Variables.Items['originalurl'], [ rfReplaceAll, rfIgnoreCase ]);
				lErrorPage.Text := StringReplace(lErrorPage.Text, '$decodedoriginalurl$', URLDecodeString(lHTTPRequest.Variables.Items['originalurl']), [ rfReplaceAll, rfIgnoreCase ]);
				lErrorPage.Text := StringReplace(lErrorPage.Text, '$portalurl$', fPortalProtocol + '://' + fPortalIP + ':' + fPortalPort, [ rfReplaceAll, rfIgnoreCase ]);
				{ Debug } WriteLn('OK page.');
				lOkPage.Text := StringReplace(lOkPage.Text, '$originalurl$', lHTTPRequest.Variables.Items['originalurl'], [ rfReplaceAll, rfIgnoreCase ]);						
				lOKPage.Text := StringReplace(lOKPage.Text, '$decodedoriginalurl$', URLDecodeString(lHTTPRequest.Variables.Items['originalurl']), [ rfReplaceAll, rfIgnoreCase ]);
				lOKPage.Text := StringReplace(lOKPage.Text, '$portalurl$', fPortalProtocol + '://' + fPortalIP + ':' + fPortalPort, [ rfReplaceAll, rfIgnoreCase ]);
			End
			Else
			Begin
				{ Debug } WriteLn('Cant find variable originalurl.');
			End;
		Except
			On E: Exception Do
			Begin
				WriteLn(E.Message);
			End;
		End;
	End;
	
	Procedure LoginOK;
	Begin
		{ Debug } WriteLn('=====================');
		{ Debug } WriteLn('Login OK !');
		lHTTPResponse.Code := 200;
		lHTTPResponse.Reason := 'OK';
		lHTTPResponse.Protocol := 'HTTP/1.0';
		lHTTPResponse.Content := lOKPage.Text;			
		lHTTPResponse.AddHeader('Connection', 'close');
		lHTTPResponse.AddHeader('Content-Type', 'text/html');
		lHTTPResponse.WriteToSocket(fSocket);
	End;
	
	Procedure LoginError;
	Begin
		{ Debug } WriteLn('=====================');
		{ Debug } WriteLn('Login error !');
		lHTTPResponse.Code := 200;
		lHTTPResponse.Reason := 'OK';
		lHTTPResponse.Protocol := 'HTTP/1.0';
		lHTTPResponse.Content := lErrorPage.Text;			
		lHTTPResponse.AddHeader('Connection', 'close');
		lHTTPResponse.AddHeader('Content-Type', 'text/html');
		lHTTPResponse.WriteToSocket(fSocket);
	End;
	
	Procedure DoLogin;
	Var
		lAppResult : String;
	Begin
		{ Debug } WriteLn('Trying to login.');
		If Assigned(lHTTPRequest.Variables.Find('login')) And Assigned(lHTTPRequest.Variables.Find('password')) Then
		Begin
			{ Debug } WriteLn('Calling external script : ', aDefaultLoginProgram);
			lAppResult := ExecuteExternalApp(aDefaultLoginProgram, [ lHTTPRequest.Variables.Items['login'], lHTTPRequest.Variables.Items['password'], fSocket.GetRemoteSinIP, IntToStr(fSocket.GetRemoteSinPort), fSocket.GetLocalSinIP, IntToStr(fSocket.GetLocalSinPort) ]);
			{ Debug } WriteLn('Script result : ', lAppResult);
			If LowerCase(Copy(lAppResult, 1, Length('authorize'))) = 'authorize' Then
				LoginOK
			Else
				LoginError;
		End
		Else
			LoginError;
	End;
	
	Procedure ShowLogin;
	Begin
		{ Debug } WriteLn('=====================');
		{ Debug } WriteLn('Show login page.');
		lHTTPResponse.Code := 200;
		lHTTPResponse.Reason := 'OK';
		lHTTPResponse.Protocol := 'HTTP/1.0';
		lHTTPResponse.Content := lLoginPage.Text;			
		lHTTPResponse.AddHeader('Connection', 'close');
		lHTTPResponse.AddHeader('Content-Type', 'text/html');
		lHTTPResponse.WriteToSocket(fSocket);
	End;

Begin
	{ Debug } WriteLn('Portal auth incomming request.');
	lLoginPage := TStringList.Create;
	lErrorPage := TStringList.Create;
	lOKPage := TStringList.Create;
	lHTTPRequest := THTTPRequest.Create;
	lHTTPResponse := THTTPResponse.Create;
	Try
		{ Debug } WriteLn('Receiving request.');
		lHTTPRequest.ReadFromSocket(fSocket);
		{ Debug } WriteLn('Reading resource pages.');
		ReadPages;
		{ Debug } WriteLn('Checking for action type.');
		If Assigned(lHTTPRequest.Variables.Find('action')) And (LowerCase(lHTTPRequest.Variables.Items['action']) = 'login') Then
			DoLogin
		Else
			ShowLogin;
	Finally
		FreeAndNil(lLoginPage);
		FreeAndNil(lErrorPage);
		FreeAndNil(lOKPage);
		FreeAndNil(lHTTPResponse);
		FreeAndNil(lHTTPRequest);
	End;	
End;

End.